home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0044_DATE-TIME Procedures.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  14KB  |  628 lines
  1. {
  2.  
  3. Various Date and Time Procedures
  4.  
  5. Rev. 1.06
  6.  
  7. (c) Copyright 1994, Michael Gallias
  8.  
  9. Target: Real, Protected, Windows
  10.  
  11. }
  12.  
  13. {$V-} {$B-}
  14.  
  15. Unit Calendar;
  16.  
  17. Interface
  18.  
  19. {$IFDEF WINDOWS}
  20.  
  21. Uses WinDos, PasStr;
  22.  
  23. {$ELSE}
  24.  
  25. Uses Dos, PasStr;
  26.  
  27. {$ENDIF}
  28.  
  29. Const
  30.   dts_DDMYYYY       =  1;
  31.   dts_DDMMYYYY      =  2;
  32.   dts_DDMMMYYYY     =  3;
  33.  
  34. Type
  35.   TimeDate = Record
  36.                Year,
  37.                Month,
  38.                Day,
  39.                WeekDay,
  40.                Hour,
  41.                Min,
  42.                Sec,
  43.                ms         :Word;
  44.              End;
  45.  
  46.   DayNameString   = String[9];
  47.   DayNameArray    = Array [0..6] of DayNameString;
  48.   MonthNameString = String[10];
  49.   MonthNameArray  = Array [1..12] of MonthNameString;
  50.   MonthAbrString  = String[3];
  51.   MonthAbrArray   = Array [1..12] of MonthAbrString;
  52.  
  53. Const
  54.   DayName     : DayNameArray =
  55.                   ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
  56.                    'Thursday', 'Friday', 'Saturday');
  57.  
  58.   MonthName   : MonthNameArray =
  59.                   ('January', 'February', 'March', 'April', 'May',
  60.                    'June', 'July', 'August', 'September',
  61.                    'October', 'November', 'December');
  62.  
  63.   MonthAbr    : MonthNameArray =
  64.                   ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  65.                    'Jun', 'Jul', 'Aug', 'Sep',
  66.                    'Oct', 'Nov', 'Dec');
  67.  
  68. Procedure StringToDate      (Strg:String; Var Date:TimeDate;
  69.                              Const Style:Byte; Var Code:Integer);
  70. Procedure DateToString      (Date:TimeDate; Var Strg:String; Const Style:Byte);
  71. Procedure StringToTime      (Strg:String; Var Time:TimeDate; Var Code:Integer);
  72. Procedure TimeToString      (Time:TimeDate; Var Strg:String);
  73. Procedure MMDDToDDMM        (DateIn:String; Var DateOut:String);
  74. Procedure GetTimeDate       (Var Time:TimeDate);
  75. Procedure PredMin           (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  76. Procedure PredHour          (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  77. Procedure UntotalDays       (Total:LongInt; Var Date:TimeDate);
  78. Procedure DayOfWeek         (Var   Date:TimeDate);
  79. Function  DayOfYear         (Const Date:TimeDate):Word;
  80. Function  TotalMonths       (Const Date:TimeDate):LongInt;
  81. Function  TotalDays         (Const Date:TimeDate):LongInt;
  82. Function  TotalHalfHrs      (Const Time:TimeDate):Byte;
  83. Function  TotalMinutes      (Const Time:TimeDate):Word;
  84. Function  TotalSeconds      (Const Time:TimeDate):LongInt;
  85. Function  Totalms           (Const Time:TimeDate):LongInt;
  86. Function  ChangedTime       (Const Time1, Time2:TimeDate):Boolean;
  87. Function  ChangedTimeDate   (Const Time1, Time2:TimeDate):Boolean;
  88. Function  ChangedDate       (Const Date1, Date2:TimeDate):Boolean;
  89. Function  DaysInMonth       (Month:Byte;Year:Word):Byte;
  90. Function  DaysInYear        (Year:Word):Word;
  91.  
  92. Implementation
  93.  
  94. Procedure StringToDate(Strg:String;Var Date:TimeDate;
  95.                        Const Style:Byte; Var Code:Integer);
  96.  
  97. Var
  98.   SY,SM,SD,ST :String;
  99.   AY,AM,AD,AT :LongInt;
  100.  
  101. Begin
  102.   Code:=0;
  103.   Case Style Of
  104.     dts_DDMMYYYY:
  105.       Begin
  106.         Strg:=Strg+'/';
  107.         SY:='';
  108.         SM:='';
  109.         SD:='';
  110.  
  111.         SD:=Copy(Strg,1,Pos('/',Strg)-1);
  112.         Delete(Strg,1,Pos('/',Strg));
  113.  
  114.         If Pos('/',Strg)>0 Then
  115.         Begin
  116.           SM:=Copy(Strg,1,Pos('/',Strg)-1);
  117.           Delete(Strg,1,Pos('/',Strg));
  118.         End;
  119.  
  120.         If Pos('/',Strg)>0 Then
  121.         Begin
  122.           SY:=Copy(Strg,1,Pos('/',Strg)-1);
  123.           Delete(Strg,1,Pos('/',Strg));
  124.         End;
  125.  
  126.         If SY<>'' Then
  127.         Begin
  128.           If Length(SY)<3 Then SY:='19'+SY;
  129.           Val(SY,AY,Code);
  130.           If (AY<1991) Or (AY>1999) Then Code:=6;
  131.         End
  132.         Else
  133.           Code:=6;
  134.  
  135.         If SM<>'' Then
  136.         Begin
  137.           Val(SM,AM,Code);
  138.           If (AM<1) Or (AM>12) Then Code:=3;
  139.         End
  140.         Else
  141.           Code:=3;
  142.  
  143.         If SD<>'' Then
  144.         Begin
  145.           Val(SD,AD,Code);
  146.           If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
  147.         End
  148.         Else
  149.           Code:=1;
  150.       End;
  151.     dts_DDMMMYYYY,
  152.     dts_DDMYYYY:
  153.       Begin
  154.         Strg:=Strg+'   ';
  155.         SD:=Copy(Strg,1,Pos(' ',Strg)-1);
  156.         Delete(Strg,1,Pos(' ',Strg));
  157.         SM:=Copy(Strg,1,Pos(' ',Strg)-1);
  158.         Delete(Strg,1,Pos(' ',Strg));
  159.         SY:=Copy(Strg,1,Pos(' ',Strg)-1);
  160.         If (SD='') Or (SM='') Or (SY='') Then
  161.           Code:=99
  162.         Else
  163.         Begin
  164.           UpperCase(SM,SM);
  165.           AT:=0;
  166.           Repeat
  167.             Inc(AT);
  168.             UpperCase(MonthName[AT],ST);
  169.           Until (AT=12) Or (ST=SM);
  170.           If ST<>SM Then
  171.           Begin
  172.             AT:=0;
  173.             Repeat
  174.               Inc(AT);
  175.               UpperCase(MonthAbr[AT],ST);
  176.             Until (AT=12) Or (ST=SM);
  177.           End;
  178.           If ST=SM Then AM:=AT Else Code:=3;
  179.           If Code=0 Then
  180.           Begin
  181.             If Length(SY)<3 Then SY:='19'+SY;
  182.             Val(SY,AY,Code);
  183.             If (AY<1991) Or (AY>1999) Then Code:=6;
  184.           End;
  185.           If Code=0 Then
  186.           Begin
  187.             Val(SD,AD,Code);
  188.             If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
  189.           End;
  190.         End;
  191.       End;
  192.   End;
  193.   If Code=0 Then
  194.   Begin
  195.     Date.Day   :=AD;
  196.     Date.Month :=AM;
  197.     Date.Year  :=AY;
  198.   End;
  199. End;
  200.  
  201. Procedure DateToString(Date:TimeDate;Var Strg:String;Const Style:Byte);
  202.  
  203. Var
  204.   Temp:String[20];
  205.  
  206. Begin
  207.   Case Style Of
  208.     dts_DDMYYYY:
  209.       Begin
  210.         Str(Date.Day:2,Strg);
  211.         SpacesToZeros(Strg,Strg);
  212.         Temp:=MonthName[Date.Month];
  213.         Strg:=Strg+' '+Temp+' ';
  214.         Str(Date.Year:4,Temp);
  215.         Strg:=Strg+Temp;
  216.       End;
  217.     dts_DDMMYYYY:
  218.       Begin
  219.         Str(Date.Day:2,Strg);
  220.         Str(Date.Month:2,Temp);
  221.         Strg:=Strg+'/'+Temp+'/';
  222.         Str(Date.Year:4,Temp);
  223.         Strg:=Strg+Temp;
  224.         SpacesToZeros(Strg,Strg);
  225.       End;
  226.     dts_DDMMMYYYY:
  227.       Begin
  228.         Str(Date.Day:2,Strg);
  229.         SpacesToZeros(Strg,Strg);
  230.         Temp:=MonthAbr[Date.Month];
  231.         Strg:=Strg+' '+Temp+' ';
  232.         Str(Date.Year:4,Temp);
  233.         Strg:=Strg+Temp;
  234.       End;
  235.   End;
  236. End;
  237.  
  238. Procedure StringToTime(Strg:String;Var Time:TimeDate;Var Code:Integer);
  239.  
  240. Var
  241.   SH,SM,SS:String[10];
  242.   AH,AM,AS:LongInt;
  243.  
  244. Begin
  245.   Strg:=Strg+':';
  246.   SH:='';
  247.   SM:='';
  248.   SS:='';
  249.  
  250.   SH:=Copy(Strg,1,Pos(':',Strg)-1);
  251.   Delete(Strg,1,Pos(':',Strg));
  252.  
  253.   If Pos(':',Strg)>0 Then
  254.   Begin
  255.     SM:=Copy(Strg,1,Pos(':',Strg)-1);
  256.     Delete(Strg,1,Pos(':',Strg));
  257.   End;
  258.  
  259.   If Pos(':',Strg)>0 Then
  260.   Begin
  261.     SS:=Copy(Strg,1,Pos(':',Strg)-1);
  262.     Delete(Strg,1,Pos(':',Strg));
  263.   End;
  264.  
  265.   If SH<>'' Then
  266.   Begin
  267.     Val(SH,AH,Code);
  268.     If (Code>0) Or (AH<0) Or (AH>23) Then Exit;
  269.   End
  270.   Else
  271.     AH:=Time.Hour;
  272.  
  273.   If SM<>'' Then
  274.   Begin
  275.     Val(SM,AM,Code);
  276.     If (Code>0) Or (AM<0) Or (AM>59) Then Exit;
  277.   End
  278.   Else
  279.     AM:=Time.Min;
  280.  
  281.   If SS<>'' Then
  282.   Begin
  283.     Val(SS,AS,Code);
  284.     If (Code>0) Or (AS<0) Or (AS>59) Then Exit;
  285.   End
  286.   Else
  287.     AS:=Time.Sec;
  288.  
  289.   Time.Hour  :=AH;
  290.   Time.Min   :=AM;
  291.   Time.Sec   :=AS;
  292. End;
  293.  
  294. Procedure TimeToString(Time:TimeDate;Var Strg:String);
  295.  
  296. Var
  297.   Temp:String[10];
  298.  
  299. Begin
  300.   Str(Time.Hour:2,Strg);
  301.   Str(Time.Min:2,Temp);
  302.   Strg:=Strg+':'+Temp+':';
  303.   Str(Time.Sec:2,Temp);
  304.   Strg:=Strg+Temp;
  305.   SpacesToZeros(Strg,Strg);
  306. End;
  307.  
  308. Procedure MMDDToDDMM(DateIn:String;Var DateOut:String);
  309.  
  310. Var
  311.   First    :String[12];
  312.   P        :Byte;
  313.  
  314. Begin
  315.   If DateIn='' Then
  316.   Begin
  317.     DateOut:='';
  318.     Exit;
  319.   End;
  320.  
  321.   DateOut:='';
  322.   DateIn:=DateIn+' ';
  323.   P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
  324.   First:=Copy(DateIn,1,P);
  325.   Delete(DateIn,1,P);
  326.  
  327.   Repeat
  328.     P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
  329.     DateOut:=DateOut+Copy(DateIn,1,P);
  330.     Delete(DateIn,1,P);
  331.   Until Length(DateIn)=0;
  332.   P:=Max(Pos(' ',DateOut),Pos('/',DateOut));
  333.   Insert(First,DateOut,P);
  334. End;
  335.  
  336. Procedure GetTimeDate(Var Time:TimeDate);
  337. Begin
  338.   With Time do
  339.   Begin
  340.     GetTime(Hour,Min,Sec,ms);
  341.     GetDate(Year,Month,Day,WeekDay);
  342.   End;
  343. End;
  344.  
  345. Procedure PredMin(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  346. {Decreases the Time by one Minute, does not check the date if TimeOut.Day=0.}
  347. Begin
  348.   TimeOut:=TimeIn;
  349.   With TimeOut do
  350.   Begin
  351.     If Min>0 Then
  352.       Dec(Min)
  353.     Else
  354.     Begin
  355.       Min:=59;
  356.       If Hour>0 Then
  357.         Dec(Hour)
  358.       Else
  359.       Begin
  360.         Hour:=23;
  361.         If Day>0 Then
  362.         Begin
  363.           If Day>1 Then
  364.             Dec(Day)
  365.           Else
  366.           Begin
  367.             If Month>1 Then
  368.               Dec(Month)
  369.             Else
  370.             Begin
  371.               Month:=12;
  372.               If Year>0 Then Dec(Year);
  373.             End;
  374.             Day:=DaysInMonth(Month,Year);
  375.           End;
  376.         End;
  377.       End;
  378.     End;
  379.   End;
  380. End;
  381.  
  382. Procedure PredHour(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  383. {Decreases the Time by one Hour, does not check the date if TimeOut.Day=0.}
  384. Begin
  385.   TimeOut:=TimeIn;
  386.   With TimeOut do
  387.   Begin
  388.     If Hour>0 Then
  389.       Dec(Hour)
  390.     Else
  391.     Begin
  392.       Hour:=23;
  393.       If Day>0 Then
  394.       Begin
  395.         If Day>1 Then
  396.           Dec(Day)
  397.         Else
  398.         Begin
  399.           If Month>1 Then
  400.             Dec(Month)
  401.           Else
  402.           Begin
  403.             Month:=12;
  404.             If Year>0 Then Dec(Year);
  405.           End;
  406.           Day:=DaysInMonth(Month,Year);
  407.         End;
  408.       End;
  409.     End;
  410.   End;
  411. End;
  412.  
  413. Procedure UntotalDays(Total:LongInt; Var Date:TimeDate);
  414.  
  415. Const
  416.   t_1000    = 366123;   {Number of days from 0 to 1000, inclusive}
  417.   t_1500    = 549002;
  418.   t_1750    = 640441;
  419.   t_1970    = 720908;
  420.  
  421. Var
  422.   DIY, DIM      :Word;
  423.  
  424. Begin
  425.   FillChar(Date,SizeOf(Date),0);
  426.  
  427.   If Total>t_1970 Then
  428.   Begin
  429.     Dec(Total,t_1970);
  430.     Date.Year:=1971;
  431.   End
  432.   Else
  433.   If Total>t_1750 Then
  434.   Begin
  435.     Dec(Total,t_1750);
  436.     Date.Year:=1751;
  437.   End
  438.   Else
  439.   If Total>t_1500 Then
  440.   Begin
  441.     Dec(Total,t_1500);
  442.     Date.Year:=1501;
  443.   End
  444.   Else
  445.   If Total>t_1000 Then
  446.   Begin
  447.     Dec(Total,t_1000);
  448.     Date.Year:=1001;
  449.   End;
  450.  
  451.   DIY:=DaysInYear(Date.Year);
  452.   While (Total>DIY) do
  453.   Begin
  454.     Dec(Total,DaysInYear(Date.Year));
  455.     Inc(Date.Year);
  456.     DIY:=DaysInYear(Date.Year);
  457.   End;
  458.  
  459.   Date.Month:=1;
  460.   For DIY:=1 to 12 do
  461.   Begin
  462.     DIM:=DaysInMonth(DIY,Date.Year);
  463.     If Total>DIM Then
  464.     Begin
  465.       Dec(Total,DIM);
  466.       Inc(Date.Month);
  467.     End;
  468.   End;
  469.  
  470.   Date.Day:=Total;
  471. End;
  472.  
  473. Procedure DayOfWeek(Var Date:TimeDate);
  474. {Sets 'WeekDay' of Date: 1 for Monday, 0 for Sunday}
  475. Var
  476.   A,B,C    :Word;
  477.   Y,M,D,DOW:Word;
  478.  
  479. Begin
  480.   GetDate(Y,M,D,DOW);
  481.   SetDate(Date.Year,Date.Month,Date.Day);
  482.   GetDate(A,B,C,Date.WeekDay);
  483.   SetDate(Y,M,D);
  484. End;
  485.  
  486. Function DayOfYear(Const Date:TimeDate):Word;
  487.  
  488. Var
  489.   Temp  :Word;
  490.   X     :Byte;
  491.  
  492. Begin
  493.   Temp:=Date.Day;
  494.   For X:=1 to Date.Month-1 do
  495.     Inc(Temp,DaysInMonth(X,Date.Year));
  496.   DayOfYear:=Temp;
  497. End;
  498.  
  499. Function TotalMonths(Const Date:TimeDate):LongInt;
  500. Begin
  501.   TotalMonths:=(12 * (Date.Year - 1)) + Date.Month;
  502. End;
  503.  
  504. Function TotalDays(Const Date:TimeDate):LongInt;
  505.  
  506. {Returns the total number of days that have elapsed from the year 0, including
  507.  the current day, e.g. 1 Jan 0 = 1}
  508.  
  509. Const
  510.   t_1_1_1970    = 720543;
  511.  
  512. Var
  513.   Total:LongInt;
  514.   Year :Integer;
  515.   Month:Byte;
  516.   Start:Integer;
  517.  
  518. Begin
  519.   If Date.Year>=1970 Then
  520.   Begin
  521.     Total:=t_1_1_1970-1;
  522.     Start:=1970;
  523.   End
  524.   Else
  525.   Begin
  526.     Total:=0;
  527.     Start:=0;
  528.   End;
  529.  
  530.   For Year:=Start to Integer(Date.Year)-1 do
  531.     Inc(Total,DaysInYear(Year));
  532.  
  533.   For Month:=1 to Date.Month-1 do
  534.     Inc(Total,DaysInMonth(Month,Date.Year));
  535.   TotalDays:=Total+Date.Day;
  536. End;
  537.  
  538. Function TotalHalfHrs(Const Time:TimeDate):Byte;
  539. Begin
  540.   TotalHalfHrs:=Time.Hour * 2 + (Time.Min Div 30);
  541. End;
  542.  
  543. Function TotalMinutes(Const Time:TimeDate):Word;
  544. Begin
  545.   TotalMinutes:=Time.Hour*60+Time.Min;
  546. End;
  547.  
  548. Function TotalSeconds(Const Time:TimeDate):LongInt;
  549. Begin
  550.   TotalSeconds:=LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec);
  551. End;
  552.  
  553. Function Totalms(Const Time:TimeDate):LongInt;
  554. Begin
  555.   Totalms:=(LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec))*100+LongInt(Time.ms);
  556. End;
  557.  
  558. Function ChangedTime(Const Time1, Time2:TimeDate):Boolean;
  559. Begin
  560.   If (Time1.ms  =Time2.ms  ) And
  561.      (Time1.Sec =Time2.Sec ) And
  562.      (Time1.Min =Time2.Min ) And
  563.      (Time1.Hour=Time2.Hour) Then
  564.     ChangedTime:=False
  565.   Else
  566.     ChangedTime:=True;
  567. End;
  568.  
  569. Function ChangedTimeDate(Const Time1, Time2:TimeDate):Boolean;
  570. Begin
  571.   If (Time1.ms   =Time2.ms   ) And
  572.      (Time1.Sec  =Time2.Sec  ) And
  573.      (Time1.Min  =Time2.Min  ) And
  574.      (Time1.Hour =Time2.Hour ) And
  575.      (Time1.Day  =Time2.Day  ) And
  576.      (Time1.Month=Time2.Month) And
  577.      (Time1.Year =Time2.Year ) Then
  578.     ChangedTimeDate:=False
  579.   Else
  580.     ChangedTimeDate:=True;
  581. End;
  582.  
  583. Function ChangedDate(Const Date1, Date2:TimeDate):Boolean;
  584. Begin
  585.   If (Date1.Day  =Date2.Day  ) And
  586.      (Date1.Month=Date2.Month) And
  587.      (Date1.Year =Date2.Year ) Then
  588.     ChangedDate:=False
  589.   Else
  590.     ChangedDate:=True;
  591. End;
  592.  
  593. Function DaysInMonth(Month:Byte;Year:Word):Byte;
  594. Begin
  595.   Case Month Of
  596.      1:DaysInMonth:=31;
  597.      2:Begin
  598.          If (Year Mod 100)=0 Then      {Centuary}
  599.            If (Year Mod 400)=0 Then
  600.              DaysInMonth:=29
  601.            Else
  602.              DaysInMonth:=28
  603.          Else                          {Non Centuary}
  604.            If (Year Mod 4)=0 Then
  605.              DaysInMonth:=29
  606.            Else
  607.              DaysInMonth:=28;
  608.        End;
  609.      3:DaysInMonth:=31;
  610.      4:DaysInMonth:=30;
  611.      5:DaysInMonth:=31;
  612.      6:DaysInMonth:=30;
  613.      7:DaysInMonth:=31;
  614.      8:DaysInMonth:=31;
  615.      9:DaysInMonth:=30;
  616.     10:DaysInMonth:=31;
  617.     11:DaysInMonth:=30;
  618.     12:DaysInMonth:=31;
  619.   End;
  620. End;
  621.  
  622. Function DaysInYear(Year:Word):Word;
  623. Begin
  624.   If DaysInMonth(2,Year)=29 Then DaysInYear:=366 Else DaysInYear:=365;
  625. End;
  626.  
  627. End.
  628.